home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TURB_VIS / PGC122 / BBUTIL.PAS < prev    next >
Pascal/Delphi Source File  |  1994-02-09  |  13KB  |  114 lines
  1. (* This file was mangled by Mangler 1.14 (c) Copyright 1993 by Berend de Boer *)
  2.  {$IFDEF DPMI} {$F+,X+,R-,I-,S-,X+,D+} {$ELSE} {$F+,X+,O+,R-,I-,S-,D+} {$ENDIF} UNIT BBUTIL ;INTERFACE USES OBJECTS ;
  3. CONST PRNLINEFEED =#10;PRNFORMFEED =#12;PRNCR =#13;PRNNL =#13#10;PRNLARGEON =#27+ 'W'+ #1;PRNSMALLON =#15;
  4. PRNSMALLOFF =#18;PRNLARGEOFF =#27+ 'W'+ #0;PRNCAN =#24;PRNUNDON =#27+ '-1';PRNUNDOFF =#27+ '-0';PRNBOLDON =#27+ 'E';
  5. PRNBOLDOFF =#27+ 'F';PRNDOUBLEON =#27+ 'G';PRNDOUBLEOFF =#27+ 'H';CONST MAANDEN :ARRAY [ 1 .. 12 ]  OF STRING [ 9 ]
  6. =('januari', 'februari', 'maart', 'april', 'mei', 'juni', 'juli', 'augustus', 'september', 'oktober', 'november',
  7. 'december');CONST MAXWORD =$FFFF ;TYPE PSLINK =^TSLINK ;TSLINK =RECORD VALUE :PSTRING ;NEXT :PSLINK ;END ;
  8. VAR VALCODE :WORD ;FUNCTION STRS (N :SHORTINT ):STRING ;FUNCTION STRB (N :BYTE ):STRING ;FUNCTION STRI
  9. (N :INTEGER ):STRING ;FUNCTION STRW (N :WORD ):STRING ;FUNCTION STRL (N :LONGINT ):STRING ;FUNCTION STRR (N :REAL ;
  10. WIDTH ,DECIMALS:WORD ):STRING ;FUNCTION LEADINGZERO (VALUE :WORD ):STRING ;FUNCTION HEXSTR (W :WORD ):STRING ;
  11. FUNCTION VALB (CONST S :STRING ):BYTE ;FUNCTION VALI (CONST S :STRING ):INTEGER ;FUNCTION VALW (CONST S :STRING ):WORD ;
  12. FUNCTION VALL (CONST S :STRING ):LONGINT ;FUNCTION VALR (CONST S :STRING ):REAL ;FUNCTION LOWCASE (C :CHAR ):CHAR ;
  13. FUNCTION LOWSTR (CONST S :STRING ):STRING ;FUNCTION UPSTR (CONST S :STRING ):STRING ;FUNCTION FANCYSTR (S :STRING
  14. ):STRING ;FUNCTION CPOS (C :CHAR ;CONST S :STRING ):BYTE ;FUNCTION EMPTY (CONST S :STRING ):BOOLEAN ;FUNCTION EXTRACTSTR
  15. (CONST FROM ,STARTSTR,ENDSTR:STRING ):STRING ;PROCEDURE FORMATSTR (VAR RESULT :STRING ;CONST FORMAT :STRING ;
  16. VAR PARAMS );FUNCTION FTCOPY (CONST S :STRING ;F ,T:WORD ):STRING ;FUNCTION GETDATESTR :STRING ;FUNCTION GETTIMESTR
  17. :STRING ;FUNCTION LEFTJUSTIFY (CONST S :STRING ;F_LEN :WORD ):STRING ;FUNCTION REPCHAR (C :CHAR ;COUNT :INTEGER ):STRING
  18. ;FUNCTION RIGHTJUSTIFY (CONST S :STRING ;F_LEN :WORD ):STRING ;FUNCTION SPC (COUNT :INTEGER ):STRING ;FUNCTION SPOILED
  19. (CONST S :STRING ):BOOLEAN ;FUNCTION STRIPSPC (CONST S :STRING ):STRING ;FUNCTION ZERORIGHTJUSTIFY (CONST S :STRING ;
  20. F_LEN :WORD ):STRING ;PROCEDURE FREESTR (P :PSTRING );FUNCTION GETSTR (P :PSTRING ):STRING ;PROCEDURE REPLACESTR
  21. (VAR P :PSTRING ;S :STRING );FUNCTION CMPB (CONST PTR1 ,PTR2;SIZE :WORD ):INTEGER ;FUNCTION CMPW (CONST PTR1 ,PTR2;
  22. SIZE :WORD ):INTEGER ;PROCEDURE COMPARE (VAR PTR1 ,PTR2;RSIZE :WORD ;VAR FLAG :BYTE );FUNCTION DATEVALID (CONST S :STRING
  23. ):BOOLEAN ;PROCEDURE DISCARD (VAR P );PROCEDURE DISPOSESLINK (PS :PSLINK );FUNCTION NEWSLINK (CONST STR :STRING ;
  24. ANEXT :PSLINK ):PSLINK ;PROCEDURE PRNWRITEDATE (YEAR ,MONTH,DAY:WORD );FUNCTION RND (R :REAL ):REAL ;FUNCTION SCANB
  25. (AREA :POINTER ;SIZE :WORD ;VALUE :BYTE ):WORD ;FUNCTION SCANW (AREA :POINTER ;SIZE :WORD ;VALUE :WORD ):WORD ;
  26. IMPLEMENTATION USES PRINTER , DOS ;FUNCTION STRS (N:SHORTINT):STRING ;VAR OO10:PSTRING;BEGIN ASM {} LES DI , @Result {}
  27. MOV WORD PTR OO10, DI {} MOV WORD PTR OO10+ 2 , ES {} END;STR (N , OO10 ^);END ;FUNCTION STRB (N:BYTE):STRING ;
  28. VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRB := OO1O ;END ;FUNCTION STRL (N:LONGINT):STRING ;VAR OO10:PSTRING;
  29. BEGIN ASM {} LES DI , @Result {} MOV WORD PTR OO10, DI {} MOV WORD PTR OO10+ 2 , ES {} END;STR (N , OO10 ^);END ;
  30. FUNCTION STRW (N:WORD):STRING ;VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRW := OO1O ;END ;FUNCTION STRI (N:INTEGER):STRING
  31. ;VAR OO1O:STRING ;BEGIN STR (N , OO1O );STRI := OO1O ;END ;FUNCTION STRR (N:REAL;WIDTH,DECIMALS:WORD):STRING ;
  32. VAR OO1O:STRING ;BEGIN STR (N :WIDTH :DECIMALS , OO1O );STRR := OO1O ;END ;FUNCTION LEADINGZERO (VALUE:WORD):STRING ;
  33. VAR OO1O:STRING ;BEGIN STR (VALUE , OO1O );IF LENGTH (OO1O )=1 THEN OO1O := '0'+ OO1O ;LEADINGZERO := OO1O ;END ;
  34. FUNCTION HEXSTR (W:WORD):STRING ;CONST OOIOOOI11OI1:ARRAY [ 0 .. 15 ]  OF CHAR='0123456789ABCDEF';BEGIN HEXSTR :=
  35. OOIOOOI11OI1 [ (W SHR 12 )MOD 16 ] + OOIOOOI11OI1 [ (W SHR 8 )MOD 16 ] + OOIOOOI11OI1 [ (W SHR 4 )MOD 16 ] + OOIOOOI11OI1
  36. [ W MOD 16 ] ;END ;FUNCTION VALB (CONST S:STRING ):BYTE ;VAR OIOO:WORD;BEGIN VAL (S , OIOO , VALCODE );VALB := LO (OIOO
  37. );END ;FUNCTION VALI (CONST S:STRING ):INTEGER ;VAR OIOO:INTEGER;BEGIN VAL (S , OIOO , VALCODE );VALI := OIOO ;END ;
  38. FUNCTION VALW (CONST S:STRING ):WORD ;VAR OIOO:WORD;BEGIN VAL (S , OIOO , VALCODE );VALW := OIOO ;END ;FUNCTION VALL
  39. (CONST S:STRING ):LONGINT ;VAR OIOO:LONGINT;BEGIN VAL (S , OIOO , VALCODE );VALL := OIOO ;END ;FUNCTION VALR
  40. (CONST S:STRING ):REAL ;VAR OO1I:REAL;BEGIN VAL (S , OO1I , VALCODE );VALR := OO1I ;END ;FUNCTION LOWCASE (C:CHAR):CHAR ;
  41. BEGIN IF C IN [ 'A'.. 'Z'] THEN LOWCASE := CHR (ORD (C )+ (97 - 65 ))ELSE LOWCASE := C ;END ;FUNCTION LOWSTR
  42. (CONST S:STRING ):STRING ;ASSEMBLER;ASM {} PUSH DS {} CLD {} LDS SI , S{} LES DI , @Result {} LODSB {} STOSB {}
  43. XOR AH , AH {} XCHG AX , CX {} JCXZ @3 {} @1 : {} LODSB {} CMP AL , 'A' {} JB @2 {} CMP AL , 'Z' {} JA @2 {}
  44. ADD AL , 20H {} @2 : {} STOSB {} LOOP @1 {} @3 : {} POP DS {} END;FUNCTION UPSTR (CONST S:STRING ):STRING ;ASSEMBLER;
  45. ASM {} PUSH DS {} CLD {} LDS SI , S{} LES DI , @Result {} LODSB {} STOSB {} XOR AH , AH {} XCHG AX , CX {} JCXZ @3 {}
  46. @1 : {} LODSB {} CMP AL , 'a' {} JB @2 {} CMP AL , 'z' {} JA @2 {} SUB AL , 20H {} @2 : {} STOSB {} LOOP @1 {} @3 : {}
  47. POP DS {} END;FUNCTION FANCYSTR (S:STRING ):STRING ;VAR OIlO:WORD;BEGIN S [ 1 ] := UPCASE (S [ 1 ] );FOR OIlO := 2 TO
  48. LENGTH (S ) DO IF S [ OIlO - 1 ] <> ' 'THEN S [ OIlO ] := LOWCASE (S [ OIlO ] );FANCYSTR := S ;END ;FUNCTION CPOS
  49. (C:CHAR;CONST S:STRING ):BYTE ;ASSEMBLER;ASM {} MOV AL , C{} CLD {} LES DI , S{} MOV CL , ES : [ DI ] {} MOV AH , CL {}
  50. XOR CH , CH {} JCXZ @end {} INC DI {} REPNE SCASB {} JNZ @end {} NEG CL {} ADD CL , AH {} @end : {} MOV AL , CL {} END;
  51. FUNCTION EMPTY (CONST S:STRING ):BOOLEAN ;ASSEMBLER;ASM {} LES DI , S{} MOV CL , [ ES : DI ] {} XOR CH , CH {}
  52. JCXZ @Empty {} MOV AL , ' ' {} INC DI {} CLD {} REPE SCASB {} JZ @Empty {} MOV AX , 0 {} POP BP {} RET 4 {} @Empty : {}
  53. MOV AX , 1 {} END;FUNCTION EXTRACTSTR (CONST FROM,STARTSTR,ENDSTR:STRING ):STRING ;VAR OIlO,OIll:WORD;BEGIN IF STARTSTR
  54. =''THEN OIlO := 1 ELSE OIlO := POS (STARTSTR , FROM )+ LENGTH (STARTSTR );IF ENDSTR =''THEN OIll := LENGTH (FROM )ELSE
  55. OIll := POS (ENDSTR , FROM )- 1 ;IF (OIll < OIlO )AND (LENGTH (ENDSTR )=1 )THEN BEGIN OIll := OIlO ;WHILE FROM [ OIll ]
  56. <> ENDSTR [ 1 ]  DO INC (OIll );DEC (OIll );END ;EXTRACTSTR := FTCOPY (FROM , OIlO , OIll );END ;{$L FORMAT.OBJ}
  57. PROCEDURE FORMATSTR (VAR RESULT:STRING ;CONST FORMAT:STRING ;VAR PARAMS);EXTERNAL;FUNCTION FTCOPY (CONST S:STRING ;
  58. F,T:WORD):STRING ;BEGIN {$IFOPT Q+} {$Q-} FTCOPY := COPY (S , F , T - F + 1 );{$Q+} {$ELSE} FTCOPY := COPY (S , F , T - F
  59. + 1 );{$ENDIF} END ;FUNCTION GETDATESTR :STRING ;VAR OOIl,OO0I,OIOO,OIlO11001ll:WORD;BEGIN GETDATE (OOIl , OO0I , OIOO ,
  60. OIlO11001ll );GETDATESTR := STRW (OOIl )+ '-'+ LEADINGZERO (OO0I )+ '-'+ LEADINGZERO (OIOO );END ;FUNCTION GETTIMESTR
  61. :STRING ;VAR OIlI,OO0I,OO1O,O11l0Il0:WORD;BEGIN GETTIME (OIlI , OO0I , OO1O , O11l0Il0 );GETTIMESTR := LEADINGZERO (OIlI
  62. )+ ':'+ LEADINGZERO (OO0I )+ ':'+ LEADINGZERO (OO1O );END ;FUNCTION LEFTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;
  63. BEGIN LEFTJUSTIFY := COPY (S + SPC (ABS (F_LEN - LENGTH (S ))), 1 , F_LEN );END ;FUNCTION REPCHAR (C:CHAR;
  64. COUNT:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN IF COUNT <= 0 THEN REPCHAR := ''ELSE BEGIN FILLCHAR (OO1O [ 1 ] , COUNT , C
  65. );OO1O [ 0 ] := CHR (COUNT );REPCHAR := OO1O ;END ;END ;FUNCTION RIGHTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;
  66. VAR OIOO:STRING ;BEGIN OIOO := SPC (ABS (F_LEN - LENGTH (S )))+ S ;RIGHTJUSTIFY := COPY (OIOO , LENGTH (OIOO )- F_LEN + 1
  67. , F_LEN );END ;FUNCTION SPC (COUNT:INTEGER):STRING ;VAR OO1O:STRING ;BEGIN IF COUNT <= 0 THEN SPC := ''ELSE
  68. BEGIN FILLCHAR (OO1O [ 1 ] , ABS (COUNT ), ' ');OO1O [ 0 ] := CHR (ABS (COUNT ));SPC := OO1O ;END ;END ;FUNCTION SPOILED
  69. (CONST S:STRING ):BOOLEAN ;ASSEMBLER;ASM {} CLD {} LES SI , S{} MOV CL , [ ES : SI ] {} XOR CH , CH {} JCXZ @end {}
  70. INC SI {} @next : SEGES LODSB {} CMP AL , 32 {} JB @stop {} CMP AL , 163 {} JA @stop {} LOOP @next {}
  71. @end : MOV AL , 0 {} POP BP {} RET 4 {} @stop : MOV AL , 1 {} END;FUNCTION STRIPSPC (CONST S:STRING ):STRING ;ASSEMBLER;
  72. ASM {} LES DI , S{} MOV CL , [ ES : DI ] {} MOV CH , 0 {} JCXZ @end {} MOV AL , ' ' {} ADD DI , CX {} STD {}
  73. REPE SCASB {} JNZ @@1 {} JCXZ @end {} @@1 : {} INC CL {} CLD {} LES DI , S{} INC DI {} REPE SCASB {} DEC DI {}
  74. MOV SI , DI {} MOV DX , DS {} MOV AX , ES {} MOV DS , AX {} LES DI , @Result {} INC CL {} MOV [ ES : DI ] , CL {}
  75. INC DI {} REP MOVSB {} MOV DS , DX {} POP BP {} RET 4 {} @end : {} LES DI , @Result {} MOV [ ES : DI ] , CL {} END;
  76. FUNCTION ZERORIGHTJUSTIFY (CONST S:STRING ;F_LEN:WORD):STRING ;VAR OIOO:STRING ;BEGIN OIOO := REPCHAR ('0', ABS (F_LEN -
  77. LENGTH (S )))+ S ;ZERORIGHTJUSTIFY := COPY (OIOO , LENGTH (OIOO )- F_LEN + 1 , F_LEN );END ;FUNCTION GETSTR
  78. (P:PSTRING):STRING ;ASSEMBLER;ASM {} PUSH DS {} LDS SI , P{} MOV AX , DS {} CMP AX , 0 {} JE @nilptr {}
  79. LES DI , @Result {} CLD {} MOV CL , [ SI ] {} MOV CH , 0 {} INC CX {} REP MOVSB {} POP DS {} POP BP {} RET 4 {}
  80. @nilptr : {} POP DS {} LES BX , @Result {} XOR AX , AX {} MOV [ ES : BX ] , AX {} END;PROCEDURE FREESTR (P:PSTRING);
  81. BEGIN IF P <> NIL THEN DISPOSESTR (P );END ;PROCEDURE REPLACESTR (VAR P:PSTRING;S:STRING );BEGIN DISPOSESTR (P );P :=
  82. NEWSTR (S );END ;PROCEDURE PRNWRITEDATE (YEAR,MONTH,DAY:WORD);BEGIN {$I-} WRITE (LST , LEADINGZERO (DAY ), '-');WRITE
  83. (LST , LEADINGZERO (MONTH ), '-'#39, YEAR MOD 100 );{$I+} END ;PROCEDURE COMPARE (VAR PTR1,PTR2;RSIZE:WORD;
  84. VAR FLAG:BYTE);ASSEMBLER;ASM {} MOV DX , DS {} LDS SI , PTR2{} LES DI , PTR1{} CLD {} MOV CX , RSIZE{} REPE CMPSW {}
  85. LDS BX , FLAG{} JAE @@1 {} MOV BYTE PTR [ BX ] , 01h {} MOV DS , DX {} POP BP {} RET 12 {} @@1 : JNE @@2 {}
  86. MOV BYTE PTR [ BX ] , 0h {} MOV DS , DX {} POP BP {} RET 12 {} @@2 : MOV BYTE PTR [ BX ] , 0FFh {} MOV DS , DX {} END;
  87. FUNCTION CMPB (CONST PTR1,PTR2;SIZE:WORD):INTEGER ;ASSEMBLER;ASM {} MOV DX , DS {} LDS SI , PTR2{} LES DI , PTR1{} CLD {}
  88. MOV CX , SIZE{} REPE CMPSB {} JAE @@AboveOrEqual {} MOV AX , 01h {} MOV DS , DX {} POP BP {} RET @Params {}
  89. @@AboveOrEqual : {} JNE @@Above {} MOV AX , 0h {} MOV DS , DX {} POP BP {} RET @Params {} @@Above : {} MOV AX , 0ffffh {}
  90. MOV DS , DX {} END;FUNCTION CMPW (CONST PTR1,PTR2;SIZE:WORD):INTEGER ;ASSEMBLER;ASM {} MOV DX , DS {} LDS SI , PTR2{}
  91. LES DI , PTR1{} CLD {} MOV CX , SIZE{} REPE CMPSW {} JAE @@AboveOrEqual {} MOV AX , 01h {} MOV DS , DX {} POP BP {}
  92. RET @Params {} @@AboveOrEqual : {} JNE @@Above {} MOV AX , 0h {} MOV DS , DX {} POP BP {} RET @Params {} @@Above : {}
  93. MOV AX , 0ffffh {} MOV DS , DX {} END;FUNCTION SCANB (AREA:POINTER;SIZE:WORD;VALUE:BYTE):WORD ;ASSEMBLER;ASM {}
  94. MOV AL , VALUE{} CLD {} LES DI , AREA{} MOV CX , SIZE{} MOV BX , CX {} JCXZ @end {} REPNE SCASB {} JNZ @end {} NEG CX {}
  95. ADD CX , BX {} @end : {} MOV AX , CX {} END;FUNCTION SCANW (AREA:POINTER;SIZE:WORD;VALUE:WORD):WORD ;ASSEMBLER;ASM {}
  96. MOV AX , VALUE{} CLD {} LES DI , AREA{} MOV CX , SIZE{} MOV BX , CX {} JCXZ @end {} REPNE SCASW {} JNZ @end {} NEG CX {}
  97. ADD CX , BX {} @end : {} MOV AX , CX {} END;FUNCTION NEWSLINK (CONST STR:STRING ;ANEXT:PSLINK):PSLINK ;
  98. VAR OI1000l1II00:PSLINK;BEGIN NEW (OI1000l1II00 );OI1000l1II00 ^. VALUE := NEWSTR (STR );OI1000l1II00 ^. NEXT := ANEXT ;
  99. NEWSLINK := OI1000l1II00 ;END ;FUNCTION RND (R:REAL):REAL ;VAR OO1O:STRING ;OI0ll01lOOOl:WORD;O11IlIIO:INTEGER;BEGIN STR
  100. (R :20 :3 , OO1O );IF OO1O [ LENGTH (OO1O )- 2 ] ='-'THEN BEGIN O11IlIIO := POS ('.', OO1O )+ 2 ;IF OO1O [ O11IlIIO + 1 ]
  101. >= '5'THEN BEGIN INC (BYTE (OO1O [ O11IlIIO ] ));WHILE OO1O [ O11IlIIO ] =':' DO BEGIN OO1O [ O11IlIIO ] := '0';DEC
  102. (O11IlIIO );IF OO1O [ O11IlIIO ] ='.'THEN DEC (O11IlIIO );INC (OO1O [ O11IlIIO ] );END ;END ;VAL (COPY (OO1O , 1 ,
  103. O11IlIIO ), R , OI0ll01lOOOl );END ELSE BEGIN O11IlIIO := POS ('.', OO1O )+ 2 ;IF OO1O [ O11IlIIO + 1 ] >= '5'THEN
  104. BEGIN INC (BYTE (OO1O [ O11IlIIO ] ));WHILE OO1O [ O11IlIIO ] =':' DO BEGIN OO1O [ O11IlIIO ] := '0';DEC (O11IlIIO );IF
  105. OO1O [ O11IlIIO ] ='.'THEN DEC (O11IlIIO );INC (OO1O [ O11IlIIO ] );END ;END ;VAL (COPY (OO1O , 1 , O11IlIIO ), R ,
  106. OI0ll01lOOOl );END ;RND := R ;END ;FUNCTION DATEVALID (CONST S:STRING ):BOOLEAN ;VAR OOIl,OO0I,OIOO:WORD;BEGIN DATEVALID
  107. := FALSE ;IF LENGTH (S )<> 8 THEN EXIT ;OOIl := 1900 + VALW (COPY (S , 1 , 2 ));IF VALCODE <> 0 THEN EXIT ;OO0I := VALW
  108. (COPY (S , 5 , 2 ));IF VALCODE <> 0 THEN EXIT ;OIOO := VALW (COPY (S , 7 , 2 ));IF VALCODE <> 0 THEN EXIT ;IF OIOO < 1
  109. THEN EXIT ;CASE OO0I  OF 1 , 3 , 5 , 7 , 8 , 10 , 12 :IF OIOO > 31 THEN EXIT ;4 , 6 , 9 , 11 :IF OIOO > 30 THEN EXIT ;2
  110. :BEGIN IF OIOO > 29 THEN EXIT ;IF (OO0I MOD 4 <> 0 )AND (OIOO =29 )THEN EXIT ;END ;ELSE EXIT ;END ;DATEVALID := TRUE ;
  111. END ;PROCEDURE DISCARD (VAR P);VAR O11III0l:POBJECT ABSOLUTE P;BEGIN IF O11III0l <> NIL THEN BEGIN DISPOSE (O11III0l ,
  112. DONE );O11III0l := NIL ;END ;END ;PROCEDURE DISPOSESLINK (PS:PSLINK);BEGIN IF PS <> NIL THEN BEGIN DISPOSESLINK (PS ^.
  113. NEXT );DISPOSESTR (PS ^. VALUE );DISPOSE (PS );END ;END ;END .
  114.